perm filename SCANZ.F4[LX,LCS] blob
sn#168994 filedate 1975-07-17 generic text, type T, neo UTF8
00100 C ***** SCANNER *************************
00200 C* SCANR,BGSORT,FMT,RANR,SQYY,COLTTY,READER,CLEAN,ACCEL,POINTR 7/74
00300 SUBROUTINE SCANR
00400 DIMENSION IP(30)
00500 COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
00600 1 ,IQ(27),ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
00700 1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
00800 EQUIVALENCE(IF,ISCA(6)),(ISS,ISCA(9)),(IE,ISCA(5)),(IDOT,IDAT(11))
00900 1 ,(IEN,ISCA(4)),(IP,PL)
01000 C 2/74 IP IS NOW EQUIV TO PL! USED TO BE IP WITH P.(HURT 'TAP' ROUTINE.)
01100 C WILL THIS DO ANYTHING TO MUSIC5 VERSION??
01200 NNUM=-1
01300 ISKP=0
01400 JJ=0
01500 XMINUS=1.
01600 999 IDECI=-1
01700 M=0
01800 2799 N=INP(ML)
01900 IF(N.NE.IQT)GO TO 899
02000 JA=-1
02100 ML=ML+1
02200 ISUB=8
02300 JJ=JJ+1
02400 VX(JJ)=ML
02500 C POINTS TO FIRST LIT. CHAR.
02600 DO 1177 K=ML,144
02700 IF(INP(K).NE.IQT)GO TO 1177
02800 ML=K+1
02900 2177 N=INP(ML)
03000 GO TO 899
03100 1177 CONTINUE
03200 C SKIPS 'LIT' ITEMS IN RAN. SELECTION
03300 899 ML=ML+1
03400 IF(N.EQ.ISEMI)GO TO 751
03500 IF(N.NE.IBLA)GO TO 510
03600 4702 IF(ISKP)202,2799,2799
03700
03800 510 IF(JA)GO TO 70
03900 C********** MAY 22,71
04000 DO 77 K=1,12
04100 IF(N.NE.ISCA(K))GO TO 77
04200 IF(K.EQ.2)GO TO 1511
04300 IF(K.NE.4)GO TO 511
04400 1511 NSWCH=K-4
04500 GO TO 2177
04600 C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
04700 C ************ MAY 22,71
04800 511 NNUM=K
04900 JJ=JJ+1
05000 NFLG=-1
05100 N=INP(ML)
05200 IF(N.NE.IF)GO TO 410
05300 NNUM=NNUM-1
05400 GO TO 610
05500 410 IF(N.NE.ISS)GO TO 3410
05600 NNUM=NNUM+1
05700 610 ML=ML+1
05800 N=INP(ML)
05900 3410 IF(N.EQ.IEN)GO TO 3411
06000 IF(N.NE.'I')GO TO 371
06100 C 'END' OR 'FINE' WILL END INST.
06200 C******** MAY 20,71
06300 3411 VX(JJ)=10000.
06400 IF(DUR(LK))DUR(LK)=1000.
06500 IAMP=-1
06600 RETURN
06700 371 IF(N.EQ.ISEMI)GO TO 5410
06800 IF(N.EQ.IBLA)GO TO 5410
06900 DO 177 KN=2,9
07000 IF(N.NE.IDAT(KN))GO TO 177
07050 IF(KN.EQ.9)CALL ERR(4)
07075 C FOUND OCTAVE NUM.8 -- TOO HIGH!
07100 JSCA=KN-2
07200 ML=ML+1
07300 GO TO 2410
07400 177 CONTINUE
07500 GO TO 6410
07600 5410 KN=-1
07700 6410 IF(NSWCH.EQ.0)GO TO 2410
07800 IF(KN)GO TO 7410
07900 CC IF(N.EQ.'+')NOLD=NOLD+6
08000 CC IF(N.EQ.'-')NOLD=NOLD-6
08100 C /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
08200 7410 IF(NOLD-NNUM.LE.5)GO TO 7411
08300 IF(JSCA.LT.7)JSCA=JSCA+1
08400 7411 IF(NOLD-NNUM.GE.-5)GO TO 2410
08500 IF(JSCA.GT.0)JSCA=JSCA-1
08600 C WILL JUMP TO NEAREST NOTE *********** MAY 22,71
08700 2410 VX(JJ)=JSCA*12+NNUM
08800 NOLD=NNUM
08900 C ********** MAY 22,71
09000 4410 NNUM=-2
09100 IF(INP(ML).EQ.ISEMI)RETURN
09200 C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
09300 IF(N.EQ.IXX)GO TO 210
09400 IF(N.EQ.'*')GO TO 210
09500 GO TO 310
09600 C *********MAY 22,71
09700 77 CONTINUE
09800 70 IF(N.NE.'-')GO TO 71
09900 XMINUS=-1.
10000 GO TO 2799
10100 210 JJ=JJ+1
10200 IF(JJ.EQ.1)GO TO 3310
10300 C****** MAY 19,71
10400 XMINUS=1.
10500 VX(JJ)=0
10600 C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
10700 GO TO 310
10800 71 IF(N.EQ.IXX)GO TO 210
10900 IF(N.EQ.'*')GO TO 210
11000 IF(N.EQ.'R')GO TO 73
11100
11200 1410 DO 78 K=1,11
11300 IF(N.NE.IDAT(K))GO TO 78
11400 ISKP=-1
11500 IF(N.NE.IDOT)GO TO 79
11600 IDECI=M
11700 GO TO 75
11800 79 M=M+1
11900 IP(M)=K-1
12000 GO TO 75
12100 78 CONTINUE
12200 IF(N.NE.IE)GO TO 8811
12210 IF(INP(ML).NE.IEN)GO TO 781
12220 GO TO 7811
12300 8811 IF(N.NE.IF)GO TO 781
12310 IF(INP(ML).NE.'I')GO TO 781
12400 C 'EN(D)' OR 'FI(NE)' WILL END INST.
12500 7811 JJ=1
12600 GO TO 3411
12700 781 IF(N.EQ.'/')N=ISEMI
12800 C FOR MOTIVIC TRANFORMATIONS
12900
13000 75 KN=INP(ML)
13100 IF(KN.EQ.IXX)GO TO 202
13200 IF(KN.EQ.'*')GO TO 202
13300 C FOR 2X3, 2*3, ETC. CHECK THIS OUT. 6/74
13400 CC75 IF(INP(ML).NE.IXX)GO TO 752
13500 CC ML=ML-1
13600 CC GO TO 202
13700 C FOR 'X' AND '*' WITHOUT SPACES.
13800 IF(N.EQ.ISEMI)GO TO 751
13900 IF(KN.NE.1)GO TO 2799
14000 C WHEN IS INP(ML) (I.E. KN) SET TO 1?????
14100 751 IF(ISKP.EQ.0)RETURN
14200 202 IF(IDECI.NE.-1)GO TO 302
14300 IDECI=0
14400 GO TO 402
14500 302 IDECI=M-IDECI
14600 402 KN=0
14700 IEXP=M-1
14800 IF(M.LT.1)M=1
14900 DO 171 K=1,M
15000 KV=10**IEXP
15100 IF(IEXP.EQ.0)KV=1
15200 KN=KN+IP(K)*KV
15300 171 IEXP=IEXP-1
15400 A=10**IDECI
15500 IF(IDECI.EQ.0)A=1.
15600 JJ=JJ+1
15700 VX(JJ)=KN/A*XMINUS
15800 IF(ISUB.EQ.1)RETURN
15900 IF(CODE.NE.-22.)XMINUS=1.
16000 C ONLY ONE - NEEDED FOR RHY.COMPOSITE
16100 1310 IF(INP(ML).NE.1)GO TO 310
16200 VX(JJ+1)=VX(JJ)*2.
16300 JJ=JJ+1
16400 ML=ML+1
16500 GO TO 1310
16600 206 ML=ML+2
16700 3310 VX(1)=-99.
16800 C******** MAY 19,71
16900 310 ISKP=0
17000 IF(N.NE.ISEMI)GO TO 999
17100
17200 RETURN
17300 73 JJ=JJ+1
17400 IF(INP(ML).EQ.IE)GO TO 206
17500 C NEXT IS FOR A REST ('R')
17600 VX(JJ)=85.
17700 C 7/75 GO TO 4410
17710 731 N=INP(ML)
17720 IF(N.EQ.'/')RETURN
17730 IF(N.EQ.ISEMI)RETURN
17740 IF(N.NE.IBLA)GO TO 899
17750 ML=ML+1
17760 GO TO 731
17800 END
17900
18000 SUBROUTINE BGSORT(BW)
18100 C THIS SORTS BG TIMES SO NONE ARE DUPLICATED IN BNW ARRAY.
18200 C ALLOWS 100 BG TIMES.
18300 COMMON /Q/ BNW(100),NWZ
18400 DO 5308 K=1,NWZ
18500 X=BNW(K)-.0001
18600 Y=X+.0002
18700 C ROUND-OFF NONSENSE
18800 IF(BW.LE.X)GO TO 5308
18900 IF(BW.LT.Y)RETURN
18950 5308 CONTINUE
19000 NWZ=NWZ+1
19100 BNW(NWZ)=BW
19200 RETURN
19300 END
19400
19500 SUBROUTINE FMT(JFM,INP,MLX)
19600 DIMENSION JFM(3),INP(1)
19700 DO 1 MLX=2,72
19800 J=INP(MLX)
19900 IF(J.EQ.' ')GO TO 2
20000 IF(J.EQ.',')GO TO 2
20100 IF(J.EQ.';')GO TO 2
20200 1 IF(J.EQ.':')GO TO 3
20300 C SPACE=COMMA=SPACE, ALSO STOPS ON ";"
20400 3 CALL ERR(1)
20500 C ERROR IF COLON IS FOUND OR THERE IS NO END MARK
20600 2 MLX=MLX+1
20700 IF(MLX.GT.7)MLX=7
20800 JFM(2)='0'+(MLX-2)*536870912
20900 C FINDS NUMBER FOR 'A' FORMAT
21000 END
21100
21200 SUBROUTINE RANR(VX,K)
21300 C FOR RAN. SELEC. OF NOTES. FINDS HIGHEST NOTE.
21400 DIMENSION VX(1)
21500 X=VX(K)
21600 Y=VX(K+1)
21700 IF(X.GT.Y)VX(K)=X+.999
21800 IF(Y.GE.X)VX(K+1)=Y+.999
21900 RETURN
22000 END
22100
22200 SUBROUTINE SQYY(YY,X,Y,Z)
22300 YY=2.*Z/(X+Y)
22400 IF(YY.NE.0)YY=2.*(Z-X*YY)/YY**2
22500 RETURN
22600 END
22700
22800 SUBROUTINE COLTTY(JNP,JT)
22900 COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED /FRMT/J(2)
23000 DIMENSION JNP(1)
23100 DATA J(2)/'72A1)'/
23200 DO 1 K=72,1,-1
23300 1 IF(JNP(K).NE.' ')GO TO 2
23400 K=1
23500 2 IF(JT.EQ.21)GO TO 3
23600 J(1)=' (1X'
23700 IF(LN.EQ.0)GO TO 5
23800 J(1)='(I6,X'
23900 WRITE(JT,J)LN,(JNP(L),L=1,K)
24000 RETURN
24100 3 J(1)=' ('
24200 5 WRITE(JT,J)(JNP(L),L=1,K)
24300 END
24400
24500 FUNCTION READER(JNP)
24600 DIMENSION JNP(72)
24700 COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED
24800 1 /FRMT/J(2)
24900 DATA TPALN/20H(' TYPE A LINE'/) /
25000 J(1)=' ('
25100 READER=0
25200 IF(ITYP)GO TO 1
25300 6 TYPE TPALN
25400 ACCEPT J,JNP
25500 IF(JED)CALL COLTTY(JNP,21)
25600 IF(JNP(1).EQ.' ')GO TO 6
25700 RETURN
25800 1 IF(LN.NE.0)GO TO 5
25900 READ(1,J,END=3)JNP
26000 GO TO 7
26100 5 J(1)=' (I,'
26200 READ(1,J,END=3)LN,JNP
26300 7 IF(SOS)CALL COLTTY(JNP,JOUT)
26400 RETURN
26500 3 READER=-1
26600 END
26700
26800 SUBROUTINE QUAD
26900 C DUMMY -- FOR NOW. 7/74
27000 END
27100
27200 FUNCTION RMOVX(W,Y,Z)
27300 IF(W.EQ.0)W=.01
27400 IF(Y.EQ.0)Y=.01
27500 RMOVX=Y*((W/Y)**Z)
27600 END
27700
27800 SUBROUTINE CLEAN(INP,LEND)
27900 DIMENSION INP(1)
28000 C CLEAR THE END OF ARRAY
28100 M=72
28200 LEND=-1
28300 K=0
28400 1 K=K+1
28500 NN=INP(K)
28600 IF(NN.EQ.';')GO TO 2
28700 IF(NN.EQ.'/')GO TO 2
28800 IF(NN.EQ.'<')GO TO 3
28900 C USE < FOR COMMENT-- AS IN MUS10
29000 IF(NN.EQ.',')INP(K)=' '
29100 C CHANGE ALL COMMAS TO BLANKS
29200 IF(NN.EQ.':')CALL ERR(1)
29300 IF(NN.NE.'"')GO TO 4
29400 7 K=K+1
29500 IF(INP(K).EQ.'"')GO TO 4
29600 IF(K.LT.M)GO TO 7
29700 CALL ERR(5)
29800 2 LEND=K
29900 4 IF(K.LT.M)GO TO 1
30000 3 IF(LEND.GT.0)RETURN
30100 IF(M.EQ.144)CALL ERR(2)
30200 CALL READER(INP(73))
30300 C GO READ ANOTHER LINE.
30400 M=144
30500 K=72
30600 GO TO 1
30700 END
30800
30900 SUBROUTINE ERR(K)
31000 GO TO(1,2,3,4,5)K
31010 TYPE 199,K
31082 199 FORMAT(' ERROR!! LAST LINE READ =',I6)
31100 CALL EXIT
31200 1 TYPE 11
31300 CALL EXIT
31400 11 FORMAT(' ILLEGAL COLON')
31500 2 TYPE 12
31600 CALL EXIT
31610 12 FORMAT(' NO END MARK')
31700 3 TYPE 13
31705 CALL EXIT
31710 13 FORMAT(' MORE THAN 2 PARENS OPEN')
31800 4 TYPE 14
31810 CALL EXIT
31820 14 FORMAT(' SOME NUMBER TOO BIG')
31900 5 TYPE 15
32000 CALL EXIT
32200 15 FORMAT(' OPEN QUOTES')
32300 END
32400
32500 SUBROUTINE ACCEL
32600 COMMON/A/ V(2000),ROFF(27),NP(27),PCH(27,32),
32700 1 RDEV(27),IPT(27,31),XT(27),OTH(20,16),SCAL(101)
32800 1 ,P1(27),JFM(4),COPY(30),IFM(80)
32900 1 ,FINM(6),TINST(5),ENFI(5),TEDIT(4),INVIS(27)
33000 COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
33100 1 ,IQ(27),KL,X,ZPAR,KA,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
33200 1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
33300 COMMON/B/MOT,PR,T5,NINS,I,TP,RA,KZY,NWX,INONLY,MX,
33400 1 Y,Z,ISLAC,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,KB,NL,RC,W,
33500 1 ZZ,CHN,YY
33600 1 /C/LPAR,IPRN,QX,RETRO,INVRT,ICON,LCNT,
33700 1 PARENS,JZ,BY,MLX,IZ,ALL,JD,LEND,QTS,ITMP,
33800 1 LP,ILIT,NLIT,KTMP,IC,NONO,RD,IA
33900 C /C/=26
34000 IF(T5.EQ.1)GO TO 4020
34100 XA=RA
34200 7020 RA=V(IA+K)
34300 IF(RA.EQ.10000.)RETURN
34400 4020 RD=1
34500 IF(RA.LT.0)RD=-1.
34600 RA=RA*RD
34700 IF(KA.EQ.0)RA=RA-RC
34800 W=RA
34900 RB=W
35000 IF(W.LE.Z)GO TO 2020
35100 IF(Z.NE.0)GO TO 3020
35200 RA=RA/Y
35300 RB=-1.
35400 RC=0
35500 GO TO 8020
35600 3020 W=Z
35700 RC=W+RC
35800 GO TO 24
35900 2020 RC=0
36000 24 IF(X.NE.Y)GO TO 424
36100 RA=W/X
36200 GO TO 8020
36300 C DUR OF TMP + BG TIME OF TMP - NOTE VALUE -
36400 C BG TIME OF NOTE. CHN=TBG.
36500 424 RAX=XT(J)
36600 RA=(-2.*RAX+(4.*RAX**2+8.*YY*W)**.5)/(2.*YY)
36700 XT(J)=RAX+YY*RA
36800 8020 IF(KA.EQ.0)RA=RA+XA
36900 KA=1
37000 IF(RC.NE.0)GO TO 1011
37100 IF(T5.EQ.1)RETURN
37200 C T5=1 IN 'RUNIT'
37300 V(IA+K)=RA*RD
37400 IF(K.EQ.IZ)RETURN
37500 C*********** JUNE 1,71
37600 1011 IF(T5.EQ.1)GO TO 2011
37700 K=K+1
37800 IF(ZZ.NE.0)Z=Z-W
37900 IF(Z.GT.0)GO TO 7020
38000 IF(RB.EQ.-1.)GO TO 7020
38100 IC=IC+1
38200 IF(RB.EQ.W)RETURN
38300 KA=0
38400 K=K-1
38500 RETURN
38600 2011 XA=RA
38700 IF(K.GT.1)GO TO 9020
38800 K=I-6
38900 ZPAR=-9900.-CHN-ZZ
39000 DO 3011 KL=8,I
39100 IF(V(K).NE.ZPAR)GO TO 3011
39200 IF(V(K+1).EQ.990000.)GO TO 9020
39300 3011 K=K-1
39400 9020 W=ZZ
39500 IF(V(K+3))K=K+3
39600 C ABOVE IS FOR TYPED IN TEMPO CHANGES
39700 KA=K+3
39800 ZZ=V(KA)
39900 C DUR OF NEXT TEMPI
40000 X=V(KA+1)
40100 Y=V(KA+2)
40200 213 KA=0
40300 Z=ZZ
40400 CALL SQYY(YY,X,Y,Z)
40500 CHN=CHN+W
40600 XT(J)=X
40700 IF(KA.EQ.1)Z=0
40800 RA=PR
40900 KA=0
41000 K=K+3
41100 GO TO 4020
41200 END
41300
41400 SUBROUTINE POINTR(INUM,IPAR,ISTRT,KODE)
41500 COMMON/A/ V(2000)
41600 C TO FIND POINTERS TO LISTS, ETC. IN V ARRAY WHEN USING SUBR.
41700 C KODES: -22=RHY -33=NOTES -44=NUMS -46=RLIST -36=RNOTES
41800 C -11=SUBN -12=SUBR -55=MOVE NUMS -56=MOVE NOTES
41900 C -66=DUPL -88=LIT -57=MOVE RANGE NUMS -58=MOVE RNG NOTES
42000 DO 1 K=1,2000
42100 N=V(K)
42200 IF(N.LT.10000)GO TO 1
42300 IF(N/10000.NE.INUM)GO TO 1
42400 IF(MOD(N,10000).NE.IPAR)GO TO 1
42500 ISTRT=K+4
42600 KODE=V(K+2)
42700 ICNT=V(K+3)
42800 IF(IABS(KODE).LT.11)ISTRT=ISTRT-1
42900 RETURN
43000 C FINDS FIRST OCCURRENCE OF PARAM AND INST ONLY.
43100 1 CONTINUE
43200 END